home *** CD-ROM | disk | FTP | other *** search
/ AOL File Library: 4,701 to 4,800 / aol-file-protocol-4400-4701-to-4800.zip / AOLDLs / Autocad Utilities / LISP_ Bearing Distance Extractor / Bd.lsp next >
Lisp/Scheme  |  2014-12-11  |  3KB  |  82 lines
  1. ;;;
  2. ;;; BD.LSP  Copyright 2002  Leo Estember  All Rights Reserved.
  3. ;;;
  4. ;;; BD.LSP is a utility for use with AutoCAD Release 14 and up,
  5. ;;; which extracts the endpoints of a line and calculates the
  6. ;;; bearing angle and distance. The format for the bearing angle
  7. ;;; is degree/minutes/seconds and the distance is in drawing units.
  8. ;;; The data is shown on the screen via an alert box. After exiting
  9. ;;; the alert box, the program prompts the user to pick another line.
  10. ;;; The program continuously cycle through until the user cancels
  11. ;;; the command or hit the ENTER key.
  12. ;;;
  13. ;;; This program is provided "as is" without express or implied
  14. ;;; warrenty. All implied warranties of fitness for any particular 
  15. ;;; purpose and of merchantability are hereby disclaimed. All damages
  16. ;;; arising from the use of or inability to use this software is the 
  17. ;;; sole responsibility of the user. This program is "freely distributed". 
  18. ;;; Distribution of this freely distributed program is granted subject 
  19. ;;; to the following conditions:
  20. ;;;
  21. ;;; The reproduction and distribution of this software in its unaltered 
  22. ;;; form (as downloaded) is hereby granted to all Autocad end users, 
  23. ;;; Provided such reproduction and distribution is for non-commercial 
  24. ;;; use and not for profit. Distribution, repackaging or reselling of 
  25. ;;; this software and accompanying documentation for profit is not allowed 
  26. ;;; without the written authorization of the author.
  27. ;;;
  28. ;;; Good luck.
  29. ;;;
  30. ;;; L Estember
  31.  
  32. (defun rtd (x) (* x (/ 180.0 pi)))
  33.  
  34. (defun getbearing (ang / bang sdeg smin ssec str)
  35.   (cond 
  36.     ((<= 0.0 ang 90.0) (setq bang (- 90.0 ang) str1 "N" str2 "E"))  
  37.     ((< 90.0 ang 180.0) (setq bang (- ang 90.0) str1 "N" str2 "W")) 
  38.     ((= ang 180.0) (setq bang 90.0 str1 "N" str2 "W"))
  39.     ((< 180.0 ang 270.0) (setq bang (- 270.0 ang) str1 "S" str2 "W"))  
  40.     ((<= 270.0 ang 360.0) (setq bang (- ang 270.0) str1 "S" str2 "E"))
  41.   );cond
  42.   (setq str (read (rtos bang 2 8))
  43.         sdeg (fix str)
  44.         smin (* (- str sdeg) 60)
  45.         ssec (fix (* (- smin (fix smin)) 60))
  46.         bstr (strcat str1 " " (itoa sdeg) (chr 176) " " (itoa (fix smin)) "'"
  47.                " " (itoa ssec) "\"" " " str2)
  48.   )
  49.   bstr
  50. )
  51.  
  52. (defun C:BD ( / ang bdist ed ent pt1 pt2 str)
  53.   (while (setq ent (car (entsel "\nSelect line to get bearing/distance: ")))
  54.     (if (and ent (= (cdr (assoc 0 (setq ed (entget ent)))) "LINE"))
  55.       (progn
  56.         (setq ed (entget ent)
  57.               pt1 (cdr (assoc 10 ed))
  58.               pt2 (cdr (assoc 11 ed))
  59.               ang (rtd (angle pt1 pt2))
  60.               bdist (distance pt1 pt2)
  61.         );setq
  62.         (setq str (strcat (getbearing ang) "\t" (rtos bdist 2 6)))
  63.         (Alert str)
  64.       )
  65.     )
  66.   )
  67.   (princ)
  68. )
  69. (princ)
  70.  
  71. (Alert (strcat "BD.LSP" "\tLINE BEARING/DISTANCE EXTRACTOR Version 1.0\n" 
  72.                "\tCOPYRIGHT (C) 2002   Leo Estember, All Rights Reserved\n"
  73.                "\nThis freeware program extracts the endpoints of a line\n"
  74.                "and calculates the corresponding bearing and distance. An\n"
  75.                "alert box shows the results on screen.\n"
  76.                "\nAny interests, comments or suggestions can be forwarded\n"
  77.                "to the author at this e-mail address:  grevark@aol.com  \n"
  78.                "\n\t. . . . .Type BD to re-run program. . . . . .\n"
  79.        )
  80. )
  81. (C:BD)
  82. (princ)